home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / modules.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-07-15  |  44.2 KB  |  1,981 lines
  1. /* ******************************************************************** */
  2. /*  modules.c        copyright (c) codemist and university of bath 1989 */
  3. /*                                                                      */
  4. /* creation of modules                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: modules.c,v 2.1 93/01/17 17:25:21 pab Exp $
  9.  *
  10.  * $Log:    modules.c,v $
  11.  * Revision 2.1  93/01/17  17:25:21  pab
  12.  * 17 Jan 1993 The next generation...
  13.  * 
  14.  * Revision 1.28  1992/11/26  15:58:09  pab
  15.  * Env removal,etc
  16.  *
  17.  * Revision 1.26  1992/05/28  11:26:40  pab
  18.  * not a lot
  19.  *
  20.  * Revision 1.25  1992/05/19  11:25:07  pab
  21.  * bindings exported with write permission, errors msgs improved
  22.  *
  23.  * Revision 1.24  1992/04/27  21:58:15  pab
  24.  * added more BCI dependency, plus corrected listify(c_fn)
  25.  *
  26.  * Revision 1.23  1992/04/26  20:55:02  pab
  27.  * fixes for interpreter
  28.  *
  29.  * Revision 1.22  1992/03/14  16:39:20  pab
  30.  * arg checking (again)
  31.  *
  32.  * Revision 1.21  1992/03/14  14:33:48  pab
  33.  * bytecode optional
  34.  *
  35.  * Revision 1.20  1992/03/07  21:45:16  pab
  36.  * apply changes
  37.  *
  38.  * Revision 1.19  1992/02/27  15:48:17  pab
  39.  * bytecode additions
  40.  *
  41.  * Revision 1.18  1992/02/10  12:06:20  pab
  42.  * new apply functions
  43.  *
  44.  * Revision 1.17  1992/02/02  16:33:47  pab
  45.  * improved backtrace output
  46.  *
  47.  * revision 1.12  1991/04/02  21:25:30  kjp
  48.  * compiler tidying.
  49.  *
  50.  * revision 1.11  1991/03/27  17:37:32  kjp
  51.  * fixed some definition ordering problems.
  52.  *
  53.  * revision 1.10  1991/03/14  14:14:14  fdla
  54.  * *** empty log message ***
  55.  *
  56.  * revision 1.9  1991/03/14  11:43:54  fdla
  57.  * c and elvira function switches expanded (20 args)
  58.  *
  59.  * revision 1.8  1991/03/13  16:57:34  kjp
  60.  * no change.
  61.  *
  62.  * revision 1.7  1991/02/19  18:53:04  kjp
  63.  * (expose spec*) in module body for reexportation.
  64.  *
  65.  * revision 1.6  1991/02/19  17:07:17  kjp
  66.  * updated for new module syntax with full streaming.
  67.  *
  68.  * revision 1.5  1991/02/13  18:24:17  kjp
  69.  * pass.
  70.  *
  71.  */
  72.  
  73. /*
  74.  * change log:
  75.  *   version 1, may 1989
  76.  *    major rewrite after talking to jap
  77.  *    added include function
  78.  *
  79.  *      threw it all away and did it again 'right' ! kjp (15/3/90)    
  80.  *    Did the same... pab (11/91)
  81.  */
  82. #include <limits.h>
  83.  
  84. #include "defs.h"
  85. #include "structs.h"
  86. #include "funcalls.h"
  87.  
  88. #include "error.h"
  89. #include "global.h"
  90.  
  91.  
  92. #include "allocate.h"
  93. #include "lists.h"
  94. #include "table.h"
  95. #include "modules.h"
  96. #include "toplevel.h"
  97. #include "symboot.h"
  98. #include "specials.h"
  99. #include "root.h"
  100. #include "class.h"
  101. #include "ngenerics.h"
  102. #include "calls.h"
  103. #include "bvf.h"
  104. #include "threads.h"
  105. #include "streams.h"
  106. #include "reader.h"
  107.  
  108. /* elsewheres... */
  109. EUDECL(call_generic);
  110. /* in modules.h */
  111. EUDECL(Fn_module_value);
  112. static EUDECL(module_set_new_aux);
  113. EUDECL(register_module_import);
  114. static LispObject export_filter(LispObject *,LispObject,LispObject);
  115. static LispObject union_filter(LispObject *,LispObject,LispObject);
  116. static LispObject filter_import_thang(LispObject*,LispObject,LispObject);
  117. LispObject symbol_ref(LispObject *,LispObject,LispObject,LispObject);
  118. static LispObject sym_include_forms;
  119.  
  120. SYSTEM_GLOBAL(LispObject,current_interactive_module);
  121.  
  122. /* global module table --- needed for modops, etc*/
  123.  
  124. LispObject global_module_table;
  125.  
  126. /* Callback when we ge a function we can't deal with */
  127. LispObject Cb_no_function_fn;
  128.  
  129. /* hooking / unhooking */
  130.  
  131. LispObject put_module(LispObject *stacktop, LispObject name,LispObject module)
  132. {
  133.   if (global_module_table == NULL) {
  134.     fprintf(stderr,"initerror: NULL module table");
  135.     exit(1);
  136.   }
  137.   STACK_TMP(name);
  138.   EUCALL_3(Fn_table_ref_setter, global_module_table,name,module);
  139.   UNSTACK_TMP(name);
  140.   return(name);
  141. }
  142.  
  143. LispObject get_module(LispObject *stacktop, LispObject name)
  144. {
  145.   ARG_1(stacktop) = name;
  146.   ARG_0(stacktop) = global_module_table;
  147.   return(Fn_table_ref(stacktop));
  148. }
  149.  
  150. int module_loaded_p(LispObject* stacktop, LispObject name)
  151. {
  152.   return((get_module(stacktop, name) != nil));
  153. }
  154.  
  155. /* utilities !! */
  156.  
  157.  
  158. LispObject module_exports(LispObject mod)
  159. {
  160.   if (is_c_module(mod)) return(mod->C_MODULE.exported_names);
  161.   if (is_i_module(mod)) return(mod->I_MODULE.exported_names);
  162.  
  163.   CallError(NULL, "module exports: unknown module type",mod,NONCONTINUABLE);
  164.  
  165.   return(nil);
  166. }
  167.  
  168. void process_expose_form(LispObject *stacktop,LispObject mod,LispObject forms)
  169. {
  170.   LispObject xx;
  171.  
  172.   STACK_TMP(mod);
  173.   xx=union_filter(stacktop,forms,mod);
  174.   UNSTACK_TMP(mod);
  175.   (void) export_filter(stacktop,xx,mod);
  176. }    
  177.       
  178. EUFUN_2( process_exports, mod, names)
  179. {
  180.  
  181.   if (is_c_module(mod))
  182.     CallError(stacktop,
  183.           "process exports: can't modify compiled module exports",
  184.           mod,NONCONTINUABLE);
  185.  
  186.   if (is_i_module(mod)) {
  187.     LispObject walker = names;
  188.  
  189.     if (names == nil) return nil;
  190.  
  191.     mod->I_MODULE.bounce_flag = lisptrue;
  192.  
  193.     while (is_cons(walker)) {
  194.  
  195.       if (!is_symbol(CAR(walker))) {
  196.     STACK_TMP(walker);
  197.     EUCALL_2(process_top_level_form,ARG_1(stackbase)/*mod*/,CAR(walker)); 
  198.     UNSTACK_TMP(walker);
  199.       }
  200.       walker = CDR(walker);
  201.     }
  202.  
  203.     mod = ARG_0(stackbase);
  204.     mod->I_MODULE.bounce_flag = nil;
  205.  
  206.     /* all valid exports */
  207.  
  208.     walker = ARG_1(stackbase);
  209.  
  210.     while(is_cons(walker)) {
  211.       if (is_symbol(CAR(walker))) {
  212.     LispObject xx;
  213.     STACK_TMP(walker);
  214.     EUCALLSET_2(xx, Fn_memq,CAR(walker),mod->I_MODULE.exported_names);
  215.     UNSTACK_TMP(walker);
  216.     if (xx == nil) {
  217.       LispObject xx;
  218.       mod = ARG_0(stackbase);
  219.       STACK_TMP(walker);
  220.       EUCALLSET_2(xx, Fn_cons, CAR(walker),mod->I_MODULE.exported_names);
  221.       mod = ARG_0(stackbase);
  222.       mod->I_MODULE.exported_names = xx;
  223.       UNSTACK_TMP(walker);
  224.     }
  225.       }
  226.  
  227.       walker = CDR(walker);
  228.     }
  229.  
  230.     return nil;
  231.   }
  232.  
  233.   CallError(stacktop, "process exports: non-module arg",mod,NONCONTINUABLE);
  234. }
  235. EUFUN_CLOSE
  236.  
  237. #ifndef PATH_MAX
  238. #define PATH_MAX 256
  239. #endif
  240. EUFUN_2( process_included_forms, mod, forms)
  241. {
  242.   char buf[PATH_MAX+64];
  243.   LispObject path,read;
  244.   FILE *cstream;
  245.  
  246.   if (!is_cons(forms))
  247.     CallError(stacktop, "inlude-forms: missing path",forms,NONCONTINUABLE);
  248.  
  249.   if (!is_string((path = CAR(forms))))
  250.     CallError(stacktop, "include-forms: bad path",path,NONCONTINUABLE);
  251.  
  252.   cstream = fopen(stringof(path),"r");
  253.   if (cstream == NULL)
  254.     CallError(stacktop, "include-forms: can't open file",path,NONCONTINUABLE);
  255.   
  256.   sprintf(buf,"including \'%s\'\n",stringof(path));
  257.   print_string(stacktop,StdOut(),buf);
  258.  
  259.   while (1) {
  260.     read=sys_read(stacktop, cstream);
  261.     if (read == q_eof) break;
  262.     EUCALLSET_2(read,process_top_level_form,ARG_0(stackbase),read);
  263.   }
  264.  
  265.   reader_fclose(stacktop,cstream);
  266.   sprintf(buf,"included \'%s\'\n",stringof(path));
  267.   print_string(stacktop,StdOut(),buf);
  268.  
  269. }
  270. EUFUN_CLOSE
  271.  
  272. static LispObject sym_only;
  273. static LispObject sym_except;
  274.  
  275. static LispObject module_addresses(LispObject *stacktop, LispObject mod)
  276. {
  277.   LispObject exports,addresses;
  278.  
  279.   addresses = nil;
  280.   exports = mod->I_MODULE.exported_names;
  281.  
  282.   
  283.   while (is_cons(exports)) {
  284.     LispObject name, xx;
  285.     STACK_TMP(CDR(exports));
  286.     STACK_TMP(mod);
  287.     STACK_TMP(addresses);
  288.  
  289.     name = CAR(exports);
  290.     
  291.     EUCALLSET_2(xx, Fn_cons, name, mod); /* canonical address */
  292.     EUCALLSET_2(name,Fn_cons, CAR(xx)/*name*/, xx);
  293.     UNSTACK_TMP(addresses);
  294.     EUCALLSET_2(addresses, Fn_cons,name, addresses);
  295.     UNSTACK_TMP(mod);
  296.     UNSTACK_TMP(exports);
  297.   }
  298.  
  299.  
  300.   return(addresses);
  301. }
  302.  
  303. /* filters */
  304.  
  305. static LispObject only_filter(LispObject *stacktop,
  306.                   LispObject names,LispObject addresses)
  307. {
  308.   LispObject remains;
  309.  
  310.   remains = nil;
  311.  
  312.   while (is_cons(addresses)) {
  313.  
  314.     STACK_TMP(addresses);
  315.     STACK_TMP(remains);
  316.     if (EUCALL_2(Fn_memq,CAR(CAR(addresses)),names) != nil) {
  317.       UNSTACK_TMP(remains);
  318.       STACK_TMP(names);
  319.       EUCALLSET_2(remains, Fn_cons, CAR(addresses),remains);
  320.       UNSTACK_TMP(names);
  321.     }
  322.     else UNSTACK_TMP(remains);
  323.  
  324.     UNSTACK_TMP(addresses);
  325.     addresses = CDR(addresses);
  326.  
  327.   }
  328.  
  329.   return(remains);
  330. }
  331.  
  332. static LispObject except_filter(LispObject *stacktop,
  333.                 LispObject names,LispObject addresses)
  334. {
  335.   LispObject remains;
  336.  
  337.   remains = nil;
  338.  
  339.   while (is_cons(addresses)) {
  340.  
  341.     STACK_TMP(addresses);
  342.  
  343.     if (EUCALL_2(Fn_memq,CAR(CAR(addresses)),names) == nil) 
  344.       {
  345.     STACK_TMP(names);
  346.     EUCALLSET_2(remains, Fn_cons, CAR(addresses),remains);
  347.     UNSTACK_TMP(names);
  348.       }
  349.  
  350.     UNSTACK_TMP(addresses);
  351.  
  352.     addresses = CDR(addresses);
  353.  
  354.   }
  355.  
  356.   return(remains);
  357. }
  358.  
  359. static LispObject name_list_pair(LispObject *stacktop,
  360.                  LispObject k,LispObject l)
  361. {
  362.   while (is_cons(l)) {
  363.  
  364.     if (!is_cons(CAR(l)))
  365.       CallError(stacktop,
  366.         "module importation: bad rename names",l,NONCONTINUABLE);
  367.  
  368.     if (k == CAR(CAR(l))) 
  369.       return(CAR(l));
  370.     else
  371.       l = CDR(l);
  372.   }
  373.  
  374.   return(nil);
  375. }
  376.  
  377. static LispObject rename_filter(LispObject *stacktop,
  378.                 LispObject pairs,LispObject addresses)
  379. {
  380.   LispObject walker;
  381.  
  382.   walker = addresses;
  383.  
  384.   while (is_cons(walker)) {
  385.     LispObject pair;
  386.     STACK_TMP(walker);
  387.     pair = name_list_pair(stacktop,CAR(CAR(walker)),pairs);
  388.     UNSTACK_TMP(walker);
  389.     if (pair != nil) { /* to be renamed... */
  390.  
  391.       CAR(CAR(walker)) = CAR(CDR(pair));
  392.  
  393.     }
  394.  
  395.     walker = CDR(walker);
  396.   }
  397.   
  398.   return(addresses);
  399. }
  400.  
  401. static LispObject
  402.   union_filter(LispObject *stacktop, LispObject list,LispObject context)
  403. {
  404.   LispObject all;
  405.  
  406.   all = nil;
  407.  
  408.   while (is_cons(list)) {
  409.     LispObject xx;
  410.  
  411.     STACK_TMP(CDR(list));
  412.     STACK_TMP(context);
  413.     STACK_TMP(all);
  414.     xx = filter_import_thang(stacktop,CAR(list),context);
  415.     UNSTACK_TMP(all);
  416.     EUCALLSET_2(all, Fn_nconc, xx,all);
  417.     UNSTACK_TMP(context);
  418.  
  419.     UNSTACK_TMP(list);
  420.  
  421.   }
  422.  
  423.   return(all);
  424. }
  425.  
  426. static LispObject export_filter(LispObject *stacktop,
  427.                 LispObject ads,LispObject mod)
  428. {
  429.   LispObject walker;
  430.   
  431.   STACK_TMP(ads);
  432.   walker = ads;
  433.  
  434.   while (is_cons(walker)) {
  435.     LispObject name;
  436.  
  437.     name = CAR(CAR(walker)); 
  438.  
  439.     STACK_TMP(CDR(walker));
  440.  
  441.     STACK_TMP(mod);
  442.     STACK_TMP(name);
  443.     if (EUCALL_2(Fn_memq,name,mod->I_MODULE.exported_names) == nil)
  444.       {
  445.     LispObject xx;
  446.     UNSTACK_TMP(name);
  447.     EUCALLSET_2(xx, Fn_cons,name,mod->I_MODULE.exported_names);
  448.     UNSTACK_TMP(mod);
  449.     mod->I_MODULE.exported_names = xx;
  450.       }
  451.     else 
  452.       { UNSTACK_TMP(name);    
  453.     UNSTACK_TMP(mod);
  454.       }
  455.     UNSTACK_TMP(walker);
  456.  
  457.   }
  458.  
  459.   UNSTACK_TMP(ads);
  460.   return(ads);
  461. }
  462.  
  463. static void register_filtered_addresses(LispObject *stacktop,
  464.                     LispObject ads,LispObject mod)
  465. {
  466.   while (is_cons(ads)) {
  467.     LispObject first;
  468.     
  469.     first = CAR(ads); ads = CDR(ads);
  470.     STACK_TMP(mod);
  471.     STACK_TMP(ads);
  472.     EUCALL_4(register_module_import,mod,
  473.          CAR(first),CDR(CDR(first)),
  474.          CAR(CDR(first)));
  475.     UNSTACK_TMP(ads);
  476.     UNSTACK_TMP(mod);
  477.   }
  478. }
  479.     
  480. static LispObject filter_import_thang(
  481.               LispObject* stacktop, LispObject spec,LispObject context)
  482. {
  483.   LispObject op,xx;
  484.  
  485.   if (is_symbol(spec)) {
  486.     STACK_TMP(spec);
  487.     EUCALL_1(load_module,spec);
  488.     UNSTACK_TMP(spec);
  489.     xx= get_module(stacktop,spec);
  490.     return(module_addresses(stacktop,xx));
  491.   }
  492.  
  493.   if (!is_cons(spec)) 
  494.     CallError(stacktop, "module importation: invalid import spec",spec,NONCONTINUABLE);
  495.  
  496.   op = CAR(spec); spec = CDR(spec);
  497.  
  498.   if (op == sym_only) {
  499.     
  500.     if (!is_cons(spec))
  501.       CallError(stacktop, "module importation: bad only form",spec,NONCONTINUABLE);
  502.     
  503.     STACK_TMP(CAR(spec));
  504.     xx=union_filter(stacktop, CDR(spec),context);
  505.     UNSTACK_TMP(spec);
  506.     return(only_filter(stacktop,spec,xx));
  507.  
  508.   }
  509.  
  510.   if (op == sym_except) {
  511.  
  512.     if (!is_cons(spec))
  513.       CallError(stacktop, "module importation: bad except form",spec,NONCONTINUABLE);
  514.     STACK_TMP(CAR(spec));
  515.     xx=union_filter(stacktop, CDR(spec),context);
  516.     UNSTACK_TMP(spec);
  517.     return(except_filter(stacktop,spec,xx));
  518.  
  519.   }
  520.  
  521.   if (op == sym_rename) {
  522.  
  523.     if (!is_cons(spec))
  524.       CallError(stacktop, "module importation: bad rename form",spec,NONCONTINUABLE);
  525.     STACK_TMP(CAR(spec));
  526.     xx= union_filter(stacktop, CDR(spec),context);
  527.     UNSTACK_TMP(spec);
  528.     return(rename_filter(stacktop,spec,xx));
  529.  
  530.   }
  531.  
  532.   if (op == sym_export) {
  533.     STACK_TMP(spec); STACK_TMP(context);
  534.     xx=union_filter(stacktop, spec,context);
  535.     UNSTACK_TMP(context); UNSTACK_TMP(spec);
  536.     return(export_filter(stacktop,xx,context));
  537.  
  538.   }
  539.  
  540.   CallError(stacktop, "module importation: invalid import operation",op,NONCONTINUABLE);
  541.  
  542.   return(nil);
  543. }
  544.  
  545. void process_import_form(LispObject *stackbase,LispObject mod,LispObject spec)
  546. {
  547.   LispObject *stacktop=stackbase+1;
  548.   
  549.   ARG_0(stackbase)=mod;
  550.  
  551.   if (!is_cons(spec))
  552.     CallError(stacktop,
  553.           "import: invalid NULL import spec",spec,NONCONTINUABLE);
  554.  
  555.   while (is_cons(spec)) {
  556.     LispObject name = CAR(spec);
  557.     STACK_TMP(CDR(spec));
  558.  
  559.     if (is_symbol(name)) {
  560.       LispObject inmod,exports;
  561.       
  562.       STACK_TMP(name);
  563.       EUCALL_1(load_module,name);
  564.       UNSTACK_TMP(name);
  565.  
  566.       inmod = get_module(stacktop,name);
  567.       mod=ARG_0(stackbase);
  568.       exports = module_exports(inmod);
  569.  
  570.       while (exports != nil) {
  571.     STACK_TMP(mod);
  572.     STACK_TMP(inmod);
  573.     STACK_TMP(CDR(exports));
  574.     EUCALL_4(register_module_import,ARG_0(stackbase)/*mod*/,
  575.          CAR(exports),inmod,CAR(exports));
  576.     UNSTACK_TMP(exports);
  577.     UNSTACK_TMP(inmod);
  578.     UNSTACK_TMP(mod);
  579.       }
  580.  
  581.     }
  582.     else {
  583.       
  584.       CallError(stacktop,
  585.         "import: non-symbolic module name",spec,NONCONTINUABLE);
  586.  
  587.     }
  588.  
  589.     UNSTACK_TMP(spec);
  590.  
  591.   }
  592.  
  593. }
  594.  
  595. void process_import_spec(LispObject *stacktop, LispObject mod,LispObject spec)
  596. {
  597.   LispObject xx;
  598.   STACK_TMP(mod);
  599.   xx=union_filter(stacktop, spec,mod);
  600.   UNSTACK_TMP(mod);
  601.   register_filtered_addresses(stacktop,xx,mod);
  602. }
  603.  
  604.  
  605. EUFUN_2(process_top_level_form, mod, form)
  606. {
  607.   LispObject op;
  608.  
  609.   /* ok, so here's the game plan -
  610.    
  611.    * for each form, check out the car.
  612.    * if it's not a symbol - crash, probably, for the moment...
  613.    * a symbol means check out any imported macros...
  614.    *   no macros means check out special form key words...
  615.    *     none of them means error.
  616.    * expand macros once and try again.
  617.    * for matching keywords, do the bizness
  618.  
  619.    */
  620.  
  621.  top:
  622.   /* interactive hack */
  623.  
  624.   if (!is_cons(form)) RETURN_EUCALL(EUCALL_3(module_eval,mod,NULL,form));
  625.  
  626.   op = CAR(form); 
  627.  
  628.   if (is_symbol(op)) {
  629.  
  630.     /* really just check for defining forms and 'progn' */
  631.  
  632.     if (op == sym_progn) {
  633.       LispObject walker,ans = nil;
  634.       walker = form;
  635.  
  636.       walker = CDR(walker);
  637.       while (is_cons(walker)) {
  638.     STACK_TMP(CDR(walker));
  639.     mod = ARG_0(stackbase);
  640.     EUCALLSET_2(ans, process_top_level_form,mod,CAR(walker));
  641.     UNSTACK_TMP(walker);
  642.       }
  643.  
  644.       return(ans);
  645.     }
  646.  
  647.     /*
  648.     if (op == sym_define) {
  649.       return(TL_define(stacktop,mod,CDR(form)));
  650.     }
  651.     */
  652.     if (op == sym_defun)       {
  653.       return(TL_defun(stacktop,mod,CDR(form)));
  654.     }
  655.     if (op == sym_deflocal) {
  656.       return(TL_deflex(stacktop,mod,CDR(form)));
  657.     }
  658.     if (op == sym_defmacro) {
  659.       return(TL_defmacro(stacktop,mod,CDR(form)));
  660.     }
  661.  
  662.     if (op == sym_defvar) return(TL_defvar(stacktop,mod,CDR(form)));
  663.       
  664.     if (op == sym_defconstant) return(TL_defconstant(stacktop,mod,CDR(form))); 
  665.  
  666.     if (op == sym_import) {
  667.       process_import_form(stacktop,mod,CDR(form));
  668.       return(nil);
  669.     }
  670.  
  671.     if (op == sym_expose) {
  672.       process_expose_form(stacktop,mod,CDR(form)); 
  673.       return(nil);
  674.     }
  675.  
  676.     if (op == sym_export) {
  677.       EUCALL_2(process_exports,mod,CDR(form));
  678.       return(nil);
  679.     }
  680.  
  681.     if (op == sym_include_forms) {
  682.       EUCALL_2(process_included_forms,mod,CDR(form));
  683.       return(nil);
  684.     }
  685.  
  686.     /* hell, that'll do for now */
  687.  
  688.     /* try a macroexpand... */
  689.  
  690.     EUCALLSET_2(form,macroexpand_1,mod,form);
  691.     
  692.     if (CAR(CDR(form)) != nil) {
  693.       while (CAR(CDR(form))!=nil)
  694.     { form = CAR(form);
  695.       mod=ARG_0(stackbase);
  696.       EUCALLSET_2(form, macroexpand_1,mod,form);
  697.     }
  698.       
  699.       form = CAR(form);
  700.       
  701.       mod=ARG_0(stackbase);
  702.       goto top;
  703.     }
  704.  
  705.     form = CAR(form);
  706.  
  707.     /* not a macro... */
  708.  
  709.     /* ok, so for user-friendliness (ho-ho) just to a module eval */
  710.  
  711.     mod=ARG_0(stackbase);
  712.     RETURN_EUCALL(EUCALL_3(module_eval,mod,NULL,form));
  713.   }
  714.  
  715.   /* wasne a symbol - rather than crash, try eval first */
  716.  
  717.   {
  718.     LispObject ans;
  719.  
  720.     EUCALLSET_3(ans,module_eval,mod,NULL,form);
  721.     return(ans);
  722.   }
  723. }
  724. EUFUN_CLOSE
  725.  
  726. /* biggie!! */
  727.  
  728. LispObject backtrace_handle;
  729. LispObject list_backtrace;
  730.  
  731. #define PUSH_TRACE(fun,args) \
  732.   { \
  733.     STACK_TMP(args); STACK_TMP(fun); STACK_TMP(backtrace_handle); \
  734.   }
  735.  
  736. #define SET_TRACE(sp,op,env)    \
  737. {                \
  738.    *(sp)=env;            \
  739.    *((sp)+1)=op;            \
  740.    *((sp)+2)=backtrace_handle;    \
  741. }
  742.  
  743. void quickie_module_eval_backtrace(LispObject *stacktop)
  744. {
  745.   LispObject *walker;
  746.  
  747.   print_string(stacktop,StdOut(),"\n");
  748.  
  749.   for (walker = GC_STACK_BASE(); walker != GC_STACK_POINTER(); ++walker) {
  750.     
  751.     if ((*(walker)) == backtrace_handle) {
  752.       
  753.       print_string(stacktop,StdOut(),"entered: ");
  754.       EUCALL_2(Fn_print, ((*(walker-1)))->FUNCTION.name,StdOut());
  755.     }
  756.  
  757.   }
  758.  
  759.   print_string(stacktop,StdOut(),"\n");
  760.  
  761. }
  762.  
  763. void module_eval_backtrace(LispObject *stacktop)
  764. {
  765.   LispObject *walker;
  766.   LispObject env;
  767.  
  768.   for (walker = GC_STACK_BASE(); walker != stacktop; ++walker) {
  769.     
  770.     if (*walker == backtrace_handle) {
  771.       
  772.       print_string(stacktop,StdOut(),"\n");
  773.       print_string(stacktop,StdOut(),"entered: ");
  774.       EUCALL_2(Fn_print,((*(walker-1)))->FUNCTION.name,StdOut());
  775.       print_string(stacktop,StdOut(),"\n");
  776.  
  777.       if ((*(walker-2)) != NULL && (is_env(*(walker-2)))) {
  778.  
  779.     for (env = (*(walker-2)); env != NULL; env = env->ENV.next) {
  780.  
  781.       print_string(stacktop,StdOut(),"  ");
  782.       STACK_TMP(env);
  783.       generic_apply_2(stacktop,generic_prin,env->ENV.variable,StdOut());
  784.       UNSTACK_TMP(env);
  785.       STACK_TMP(env);
  786.       print_string(stacktop,StdOut(),": ");
  787.       generic_apply_2(stacktop,generic_prin,env->ENV.value,StdOut());
  788.       print_string(stacktop,StdOut(),"\n");
  789.       UNSTACK_TMP(env);
  790.     }
  791.  
  792.       }
  793.  
  794.     }
  795.  
  796.   }
  797.  
  798.   print_string(stacktop,StdOut(),"\n");
  799.  
  800. }
  801.  
  802. /* Better backtrace
  803.    * Works by examining vref(arg,0)
  804.    * if == nil begin backtrace, return vector (next end frame)
  805.    * o/w move down 1
  806.    * THIS WILL BREAK FOR LOWTAG SYSTEM !
  807.    */
  808.  
  809. EUFUN_1(Fn_backtrace_by_arg,arg)
  810. {
  811.   LispObject *walker,*oldtop;
  812.   LispObject val;
  813.   
  814.   /* First time round, we hack the vector */
  815.   if (vref(arg,0)==nil)
  816.     {
  817.       vref(arg,0)=allocate_integer(stacktop,(int)GC_STACK_BASE());
  818.       vref(arg,1)=allocate_integer(stacktop,(int)stacktop);    
  819.     }
  820.   
  821.   oldtop=(LispObject *) intval(vref(arg,1));
  822.   walker=(LispObject *) intval(vref(arg,0));
  823.  
  824.   while (walker < oldtop)
  825.     {
  826.       if (*walker == backtrace_handle)
  827.     {
  828.       LispObject ptr;
  829.       LispObject lst=nil;
  830.       
  831.       ptr= *(walker-2);
  832.       while (ptr!=NULL && is_env(ptr))
  833.         { /* oh for 1st class envs */
  834.           LispObject xx;
  835.  
  836.           STACK_TMP(ptr->ENV.next);
  837.           STACK_TMP(lst);
  838.           xx=EUCALL_2(Fn_cons,ptr->ENV.variable,ptr->ENV.value);
  839.           UNSTACK_TMP(lst);
  840.           lst=EUCALL_2(Fn_cons,xx,lst);
  841.           UNSTACK_TMP(ptr);
  842.         }
  843.       val=EUCALL_2(Fn_cons,*(walker-1),lst);
  844.       
  845.       /* return new value in vector */
  846.       vref(ARG_0(stackbase),0)=allocate_integer(stacktop,(int) (walker+1));
  847.       vref(ARG_0(stackbase),2)=val;
  848.       return lisptrue;
  849.     }
  850.       
  851.       /* test for bytecode return address.. */
  852.       
  853.       if ( ((int)*walker)&1)
  854.     {
  855.       val=EUCALL_2(Fn_cons,nil,nil);
  856.       CAR(val)=*(walker+2);
  857.       CDR(val)=*(walker+1); /* Context */
  858.       vref(ARG_0(stackbase),0)=allocate_integer(stacktop,(int) (walker+2));
  859.       vref(ARG_0(stackbase),2)=val;
  860.       return lisptrue;
  861.     }
  862.       walker++;
  863.     }
  864.   
  865.   /* no more frames */
  866.   return nil;
  867. }
  868. EUFUN_CLOSE
  869.  
  870. /*
  871.   *
  872.   * The interpreter lies below 
  873.   */
  874.  
  875. #define check_if(stmt) /* :-> */
  876.  
  877. #define ALLOCATE_N_ENVS(var,env) \
  878. {                \
  879.   var=env;                \
  880.   for (i=0 ; i< nargs; i++)        \
  881.     var=allocate_env(stacktop,nil,nil,var); \
  882. }
  883.  
  884. LispObject module_eval(LispObject *stackbase)
  885. {
  886.   LispObject module_apply_args(LispObject *stackbase, int callargs, LispObject fn);
  887.   LispObject mod,env,form;
  888.   LispObject *stacktop;
  889.   LispObject op;
  890.  
  891.   mod = ARG_0(stackbase);
  892.   env = ARG_1(stackbase);
  893.   form = ARG_2(stackbase);
  894.   stacktop=stackbase+3;
  895.   STACKS_OK_P(stacktop,form);
  896.  
  897.   stackbase+=3;    /* Room for trace */
  898.   ARG_0(stackbase)=mod;
  899.   ARG_1(stackbase)=env;
  900.   ARG_2(stackbase)=form;
  901.  toplabel:  
  902.   mod = ARG_0(stackbase);
  903.   env = ARG_1(stackbase);
  904.   form = ARG_2(stackbase);
  905.  
  906.   stacktop=stackbase+3;
  907.  
  908.   if (!is_cons(form))
  909.     { /* should check for loose special forms */
  910.       if (is_symbol(form))
  911.     {
  912.       LispObject tmp=symbol_ref(stacktop,mod,env,form);
  913.       if (!is_special(tmp)) return(tmp);
  914.       else    
  915.         CallError(stacktop,"Invalid use of reserved word",form,NONCONTINUABLE);
  916.     }
  917.       else    
  918.     return form;
  919.     }
  920.  
  921.   op = CAR(form);
  922.  
  923.   ARG_3(stackbase)=op;
  924.   stacktop++;
  925.  
  926.   if (is_symbol(op))
  927.     { 
  928. #ifndef NODEBUG
  929.       { extern int gc_paranoia;
  930.     if (gc_paranoia)
  931.       fprintf(stderr,"%s\n",stringof(op->SYMBOL.pname));
  932.       }
  933. #endif
  934.       op = symbol_ref(stacktop,mod,env,op);
  935.       ARG_3(stackbase)=op;
  936.     }
  937.   else
  938.     if (is_cons(op))
  939.       {    
  940.     op=EUCALL_3(module_eval,mod,env,op);
  941.     ARG_3(stackbase)=op;
  942.     mod=ARG_0(stackbase);
  943.     env=ARG_1(stackbase);
  944.     form=ARG_2(stackbase);
  945.       }
  946.  
  947.   if (is_macro(op))
  948.     { 
  949.       LispObject newform;
  950.       
  951.       newform = EUCALL_2(module_mv_apply_1,op,CDR(form));
  952.       /*STACK_TMP(newform);*/
  953.   ATOMIC(stacktop,
  954.      /*UNSTACK_TMP(newform);*/
  955.       if (!is_cons(newform))
  956.          form=newform;
  957.       else
  958.     {
  959.       form=ARG_2(stackbase);
  960.       CAR(form) = CAR(newform);
  961.       CDR(form) = CDR(newform);
  962.     }
  963.      )
  964.     EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,form);
  965.     }
  966.  
  967.  
  968.   if (is_c_function(op)
  969. #ifdef BCI
  970.       || is_b_function(op)
  971. #endif
  972.       )
  973.     {
  974.       LispObject lastarg;
  975.  
  976.       LispObject walker, extras = nil;
  977.       int i, args, extra;
  978.       BEGIN_NARY_EUCALL();
  979.  
  980.       walker = CDR(form);
  981. #ifdef BCI
  982.       args = ((is_c_function(op))
  983.           ? op->C_FUNCTION.argtype
  984.           : intval(bytefunction_nargs(op)));
  985. #else
  986.       args = op->C_FUNCTION.argtype;
  987. #endif
  988.       extra = (args < 0);
  989.       args = extra ? -args : args;
  990.       
  991.       if (is_c_function(op))
  992.     if (op->C_FUNCTION.env != NULL)
  993.       { STACK_TMP(nil); /* space for arg */
  994.         NARY_PUSH_ARG(op->C_FUNCTION.env);
  995.       }
  996.  
  997.       if (args==0)
  998.     {
  999.       if (walker!=nil)
  1000.         CallError(stacktop,"Too many args to C-fn",op,NONCONTINUABLE);
  1001.       else
  1002.         {
  1003. #ifdef BCI        
  1004.           if (is_b_function(op))
  1005.         {
  1006.           return(apply_nary_bytefunction(stackbase,0,op));
  1007.         }    
  1008.           else
  1009.         return(op->C_FUNCTION.func(stackbase));
  1010. #else
  1011.           return(op->C_FUNCTION.func(stackbase));
  1012. #endif
  1013.         }
  1014.     }
  1015.       for (i=0; i < args-1 ; i++)
  1016.     {
  1017.       if (walker==nil)
  1018.         CallError(stacktop,"C function wants more args", op, NONCONTINUABLE);
  1019.       STACK_TMP(nil); /* place where arg will go */
  1020.       STACK_TMP(CDR(walker));
  1021.       /* XXX assume 1) CDR(nil)=nil, module_eval(nil)=nil */
  1022.       NARY_PUSH_ARG(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,
  1023.                  ARG_1(stackbase)/* env */,CAR(walker)));
  1024.       UNSTACK_TMP(walker);
  1025.     }
  1026.  
  1027.       if (extra)
  1028.     { 
  1029.       LispObject ptr;
  1030.  
  1031.       if (walker!=nil)
  1032.         {
  1033.           LispObject xx;
  1034.  
  1035.           STACK_TMP(CDR(walker));
  1036.           EUCALLSET_3(xx,module_eval,ARG_0(stackbase) /*mod*/,
  1037.                               ARG_1(stackbase)/*env*/, CAR(walker));
  1038.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  1039.           UNSTACK_TMP(walker);
  1040.           STACK_TMP(lastarg);
  1041.           ptr = lastarg;
  1042.           while(walker!=nil)
  1043.         {    
  1044.           STACK_TMP(CDR(walker));
  1045.           STACK_TMP(ptr);
  1046.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase)    /*mod*/, 
  1047.                   ARG_1(stackbase)/*env*/, CAR(walker));
  1048.           xx = EUCALL_2(Fn_cons, xx, nil);
  1049.           UNSTACK_TMP(ptr);
  1050.           CDR(ptr)=xx;
  1051.           ptr = CDR(ptr);
  1052.           UNSTACK_TMP(walker);
  1053.         }
  1054.           UNSTACK_TMP(lastarg);
  1055.         }
  1056.       else
  1057.         lastarg=nil;
  1058.     }
  1059.       else
  1060.     {
  1061.       if (walker == nil)
  1062.         {
  1063.           CallError(stacktop,
  1064.             "C function wants more args", op, NONCONTINUABLE);
  1065.         }
  1066.  
  1067.       if (CDR(walker)!=nil)
  1068.         CallError(stacktop,"Eval: Too many args to 'C-function",CDR(walker),
  1069.               NONCONTINUABLE);
  1070.       EUCALLSET_3(lastarg,module_eval,ARG_0(stackbase)/*mod*/,
  1071.               ARG_1(stackbase)/*env*/,CAR(walker));
  1072.     }
  1073.       NARY_PUSH_ARG(lastarg);
  1074.       op=ARG_3(stackbase);
  1075.  
  1076. #ifdef BCI
  1077.       if (is_c_function(op))
  1078.     return(NARY_EUCALL(op->C_FUNCTION.func));
  1079.       else
  1080.     {    /* B-function */
  1081.       return(apply_nary_bytefunction(argbase,args,op));
  1082.     }
  1083. #else
  1084.       return(NARY_EUCALL(op->C_FUNCTION.func));
  1085. #endif
  1086.       END_NARY_EUCALL();
  1087.     }
  1088.  
  1089.   if (is_generic(op))
  1090.     { 
  1091.       RETURN_EUCALL(EUCALL_4(call_generic,mod,env,op,CDR(form)));
  1092.     }
  1093.  
  1094.  
  1095. #if 1 /* I have 2 ways of doing this --- the first is faster (5%) */
  1096.   if (is_i_function(op))
  1097.     {
  1098.       LispObject args, exps, callenv;
  1099.       int extra, nargs, i;
  1100.       extra = ( op->I_FUNCTION.argtype < 0);
  1101.       nargs = extra ? -op->I_FUNCTION.argtype : op->I_FUNCTION.argtype;
  1102.       STACK_TMP(op);
  1103.       STACK_TMP(op);
  1104.       STACK_TMP(form);
  1105.       ALLOCATE_N_ENVS(callenv,op->I_FUNCTION.env);
  1106.       UNSTACK_TMP(form);
  1107.       UNSTACK_TMP(op);
  1108.       STACK_TMP(callenv);
  1109.       if (nargs == 0)
  1110.     {
  1111.       if (CDR(form)!=nil)
  1112.         CallError(stackbase,"Too many args to I-function",op,NONCONTINUABLE);
  1113.     }
  1114.       else
  1115.     {        
  1116.       exps=callenv;
  1117.       for (args = op->I_FUNCTION.bvl ; is_cons(args) ; args=CDR(args))
  1118.         {
  1119.           exps->ENV.variable=CAR(args);
  1120.           exps=exps->ENV.next;
  1121.         }
  1122.       if (extra)
  1123.         exps->ENV.variable=args;
  1124.       
  1125.       exps = CDR(form);
  1126.       for (i=0 ; i<nargs-extra ; i++)
  1127.         {
  1128.           if (exps == nil)
  1129.         {
  1130.           CallError(stacktop,
  1131.                 "i function wants more args", op, NONCONTINUABLE);
  1132.         }
  1133.           else
  1134.         {
  1135.           LispObject nextarg;
  1136.  
  1137.           STACK_TMP(CDR(exps));
  1138.           STACK_TMP(callenv);
  1139.           EUCALLSET_3(nextarg,module_eval,
  1140.                   ARG_0(stackbase) /*mod*/,
  1141.                   ARG_1(stackbase) /*env*/,
  1142.                   CAR(exps));
  1143.           UNSTACK_TMP(callenv);
  1144.           callenv->ENV.value = nextarg;
  1145.           callenv = callenv->ENV.next;
  1146.           UNSTACK_TMP(exps);
  1147.         }
  1148.           /* end i-function-loop */
  1149.         }
  1150.                           
  1151.       /* last arg */
  1152.  
  1153.       if (extra)
  1154.         {
  1155.           LispObject lastarg=nil;
  1156.  
  1157.           STACK_TMP(callenv); /* need this */
  1158.           if (exps!=nil)
  1159.         {
  1160.           LispObject xx;
  1161.           LispObject ptr;
  1162.  
  1163.           STACK_TMP(CDR(exps));
  1164.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1165.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1166.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  1167.           UNSTACK_TMP(exps);
  1168.           STACK_TMP(lastarg);
  1169.           ptr = lastarg;
  1170.           while(exps!=nil)
  1171.             {    
  1172.               STACK_TMP(CDR(exps));
  1173.               STACK_TMP(ptr);
  1174.               EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1175.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1176.               xx = EUCALL_2(Fn_cons, xx, nil);
  1177.               UNSTACK_TMP(ptr);
  1178.               CDR(ptr)=xx;
  1179.               ptr = CDR(ptr);
  1180.               UNSTACK_TMP(exps);
  1181.             }
  1182.           UNSTACK_TMP(lastarg);
  1183.         }
  1184.           else
  1185.         lastarg=nil;
  1186.  
  1187.           UNSTACK_TMP(callenv);
  1188.           callenv->ENV.value=lastarg;
  1189.         }
  1190.       else if (exps!=nil)
  1191.         {    
  1192.           UNSTACK_TMP(callenv); UNSTACK_TMP(op);
  1193.           CallError(stackbase,"Too many args to i-function",op,NONCONTINUABLE);
  1194.         }
  1195.     }
  1196.       UNSTACK_TMP(callenv);
  1197.       UNSTACK_TMP(op);
  1198.       /* now we call it.., cunningly inlining the progn */
  1199.  
  1200.       { LispObject forms = op->I_FUNCTION.body;
  1201.     /* Throw it all away */
  1202.     stacktop=stackbase;
  1203.     SET_TRACE(stackbase-3,op,callenv);
  1204.  
  1205.     while (CDR(forms)!=nil)
  1206.       {
  1207.         STACK_TMP(CDR(forms));
  1208.         STACK_TMP(callenv);
  1209.         STACK_TMP(op);
  1210.         EUCALL_3(module_eval,
  1211.              op->I_FUNCTION.home,
  1212.              callenv,
  1213.              CAR(forms));
  1214.         UNSTACK_TMP(op);
  1215.         UNSTACK_TMP(callenv);
  1216.         UNSTACK_TMP(forms);
  1217.       }
  1218.  
  1219.     mod = ARG_0(stackbase) = op->I_FUNCTION.home;
  1220.     env = ARG_1(stackbase) = callenv;
  1221.     form = ARG_2(stackbase) = CAR(forms);
  1222.     goto toplabel;
  1223.       }
  1224.     }
  1225. #else
  1226.   if (is_i_function(op))
  1227.     {
  1228.       LispObject args, exps, callenv;
  1229.       int extra;
  1230.  
  1231.       extra = ( op->I_FUNCTION.argtype < 0);
  1232.       callenv = op->I_FUNCTION.env;
  1233.       STACK_TMP(op);
  1234.       if (op->I_FUNCTION.argtype == 0)
  1235.     {
  1236.       if (CDR(form)!=nil)
  1237.         CallError(stackbase,"Too many args to I-function",op,NONCONTINUABLE);
  1238.     }
  1239.       else
  1240.     {    
  1241.       for ((args = op->I_FUNCTION.bvl,
  1242.         exps = CDR(form));
  1243.            is_cons(args);
  1244.            (args = CDR(args),
  1245.         exps = CDR(exps)))
  1246.         {
  1247.           if (exps == nil)
  1248.         {
  1249.           CallError(stacktop,
  1250.                 "i function wants more args", op, NONCONTINUABLE);
  1251.         }
  1252.           else
  1253.         {
  1254.           LispObject nextarg;
  1255.  
  1256.           STACK_TMP(exps);
  1257.           STACK_TMP(args);
  1258.           STACK_TMP(callenv);
  1259.           EUCALLSET_3(nextarg,module_eval,
  1260.                   ARG_0(stackbase) /*mod*/,
  1261.                   ARG_1(stackbase) /*env*/,
  1262.                   CAR(exps));
  1263.           UNSTACK_TMP(callenv);
  1264.           UNSTACK_TMP(args);
  1265.           STACK_TMP(args);
  1266.           callenv = allocate_env(stacktop,CAR(args),
  1267.                      nextarg, callenv);
  1268.           UNSTACK_TMP(args);
  1269.           UNSTACK_TMP(exps);
  1270.  
  1271.         }
  1272.           /* end i-function-loop */
  1273.         }
  1274.                           
  1275.       /* last arg */
  1276.  
  1277.       if (extra)
  1278.         {
  1279.           LispObject lastarg=nil;
  1280.  
  1281.           STACK_TMP(callenv); /* need this */
  1282.           STACK_TMP(args);
  1283.  
  1284.           if (exps!=nil)
  1285.         {
  1286.           LispObject xx;
  1287.           LispObject ptr;
  1288.  
  1289.           STACK_TMP(CDR(exps));
  1290.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1291.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1292.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  1293.           UNSTACK_TMP(exps);
  1294.           STACK_TMP(lastarg);
  1295.           ptr = lastarg;
  1296.           while(exps!=nil)
  1297.             {    
  1298.               STACK_TMP(CDR(exps));
  1299.               STACK_TMP(ptr);
  1300.               EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1301.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1302.               xx = EUCALL_2(Fn_cons, xx, nil);
  1303.               UNSTACK_TMP(ptr);
  1304.               CDR(ptr)=xx;
  1305.               ptr = CDR(ptr);
  1306.               UNSTACK_TMP(exps);
  1307.             }
  1308.           UNSTACK_TMP(lastarg);
  1309.         }
  1310.           else
  1311.         lastarg=nil;
  1312.  
  1313.           UNSTACK_TMP(args);
  1314.           UNSTACK_TMP(callenv);
  1315.           callenv = allocate_env(stacktop,args,lastarg, callenv);
  1316.         }
  1317.       else if (exps!=nil)
  1318.         {    
  1319.           UNSTACK_TMP(op);
  1320.           CallError(stackbase,"Too many args to i-function",op,NONCONTINUABLE);
  1321.         }
  1322.     }
  1323.  
  1324.       UNSTACK_TMP(op);
  1325.       /* now we call it.., cunningly inlining the progn */
  1326.  
  1327.       { LispObject forms = op->I_FUNCTION.body;
  1328.     /* Throw it all away */
  1329.     stacktop=stackbase;
  1330.     SET_TRACE(stackbase-3,op,callenv);
  1331.  
  1332.     while (CDR(forms)!=nil)
  1333.       {
  1334.         STACK_TMP(CDR(forms));
  1335.         STACK_TMP(callenv);
  1336.         STACK_TMP(op);
  1337.         EUCALL_3(module_eval,
  1338.              op->I_FUNCTION.home,
  1339.              callenv,
  1340.              CAR(forms));
  1341.         UNSTACK_TMP(op);
  1342.         UNSTACK_TMP(callenv);
  1343.         UNSTACK_TMP(forms);
  1344.       }
  1345.  
  1346.     mod = ARG_0(stackbase) = op->I_FUNCTION.home;
  1347.     env = ARG_1(stackbase) = callenv;
  1348.     form = ARG_2(stackbase) = CAR(forms);
  1349.     goto toplabel;
  1350.       }
  1351.     }
  1352. #endif
  1353.   
  1354.   
  1355.   if (is_special(op))
  1356.     {
  1357.       if (op==special_progn)
  1358.     { LispObject forms = CDR(form);
  1359.     
  1360.       while (CDR(forms)!=nil)
  1361.         {
  1362.           STACK_TMP(CDR(forms));
  1363.           EUCALL_3(module_eval,
  1364.                ARG_0(stackbase)/*mod*/,
  1365.                ARG_1(stackbase)/*env*/,
  1366.                CAR(forms));
  1367.           UNSTACK_TMP(forms);
  1368.         }
  1369.  
  1370.       EUTAIL_3(ARG_0(stackbase)/*mod*/,
  1371.            ARG_1(stackbase)/*env*/,
  1372.            CAR(forms));
  1373.     }
  1374.       if (op == special_if)
  1375.     {    
  1376.       LispObject res,stmt=CDR(form);
  1377.       check_if(stmt);
  1378.       
  1379.       STACK_TMP(CDR(stmt));
  1380.       res = EUCALL_3(module_eval,mod,env,CAR(stmt));
  1381.       if ( res == nil)
  1382.         {
  1383.           UNSTACK_TMP(stmt);
  1384.           EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/
  1385.                ,CAR(CDR(stmt)));
  1386.         }
  1387.       UNSTACK_TMP(stmt);
  1388.       EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,CAR(stmt));
  1389.     }
  1390.  
  1391.       if (op->SPECIAL.env==NULL)
  1392.     RETURN_EUCALL(EUCALL_3(op->SPECIAL.func,mod,env,CDR(form)));
  1393.       else
  1394.     RETURN_EUCALL(EUCALL_2(op->SPECIAL.func,mod,CDR(form)));
  1395.     }
  1396.  
  1397.   if (is_continue(op))
  1398.     { LispObject res;
  1399.       /* CAR(nil)==nil! */
  1400.       res = EUCALL_3(module_eval,mod,env,CAR(CDR(form)));
  1401.       op=ARG_3(stackbase);
  1402.       call_continuation(stacktop,op,res);
  1403.       return nil; /* not really */
  1404.     }
  1405.   
  1406.   /* default case.. */
  1407.   {
  1408.     LispObject *ptr,*argbase,tmp;
  1409.     int nargs=0;
  1410.     
  1411.     argbase=stacktop;
  1412.     ptr=argbase;
  1413.     *ptr++=op;
  1414.     stacktop++;
  1415.     ARG_2(stackbase)=CDR(form);
  1416.   
  1417.     while (is_cons(ARG_2(stackbase)))
  1418.       {
  1419.     tmp=EUCALL_3(module_eval,mod,env,CAR(ARG_2(stackbase)));
  1420.     *ptr=tmp;
  1421.     
  1422.     mod=ARG_0(stackbase);
  1423.     env=ARG_1(stackbase);
  1424.     ARG_2(stackbase)=CDR(ARG_2(stackbase));
  1425.     stacktop++;
  1426.     nargs++;
  1427.     ptr++;
  1428.       }
  1429.     if (ARG_2(stackbase)!=nil)
  1430.       CallError(stacktop,"Eval: bad list",nil,NONCONTINUABLE);
  1431.     /* should move args down stacktop->stackbase...*/
  1432.     return (module_apply_args(argbase,nargs+1,CAR(Cb_no_function_fn)));
  1433.   }
  1434. }
  1435.  
  1436.  
  1437.  
  1438. /* The same, but different... we could be clever + do the tail call properly*/
  1439. EUFUN_4( call_generic, mod, env, gf, forms)
  1440. {
  1441.   LispObject lastarg;
  1442.   LispObject walker, extras = nil;
  1443.   int i, args, extra;
  1444.   BEGIN_NARY_EUCALL();
  1445.  
  1446.   walker = forms;
  1447.   args = intval(generic_argtype(gf));
  1448.   extra = (args < 0);
  1449.   args = extra ? -args : args;
  1450.  
  1451.   /* Too much cut and paste! */
  1452.   for (i=0; i < args-1 ; i++)
  1453.     {
  1454.       STACK_TMP(nil);        /* place where arg will go */
  1455.       STACK_TMP(CDR(walker));
  1456.       NARY_PUSH_ARG(EUCALL_3(module_eval,ARG_0(stackbase) /*mod*/,
  1457.                  ARG_1(stackbase) /* env */,CAR(walker)));
  1458.       UNSTACK_TMP(walker);
  1459.  
  1460.       if (walker == nil)
  1461.     {
  1462.       CallError(stacktop,
  1463.             "Generic function wants more args", gf, NONCONTINUABLE);
  1464.     }
  1465.     }
  1466.  
  1467.   if (extra)
  1468.     { 
  1469.       LispObject ptr;
  1470.  
  1471.       stacktop=argbase+argcount;
  1472.  
  1473.       if (walker!=nil)
  1474.     {
  1475.       STACK_TMP(CDR(walker));
  1476.       EUCALLSET_2(lastarg,Fn_cons,CAR(walker),nil);
  1477.       UNSTACK_TMP(walker);
  1478.       STACK_TMP(lastarg);
  1479.       ptr = lastarg;
  1480.       while(walker!=nil)
  1481.         {    
  1482.           LispObject xx;
  1483.           STACK_TMP(CDR(walker));
  1484.           STACK_TMP(ptr);
  1485.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase)/*mod*/, ARG_1(stackbase)/*env*/, CAR(walker));
  1486.           xx = EUCALL_2(Fn_cons, xx, nil);
  1487.           UNSTACK_TMP(ptr);
  1488.           CDR(ptr)=xx;
  1489.           ptr = CDR(ptr);
  1490.           UNSTACK_TMP(walker);
  1491.         }
  1492.       UNSTACK_TMP(lastarg);
  1493.     }
  1494.       else
  1495.     lastarg=nil;
  1496.     }
  1497.   else
  1498.     {     
  1499.       if (CDR(walker)!=nil)
  1500.     CallError(stacktop,"Eval: Too many args to Generic-function",CDR(walker),
  1501.           NONCONTINUABLE);
  1502.       EUCALLSET_3(lastarg,module_eval,ARG_0(stackbase) /*mod*/,ARG_1(stackbase)/*env*/,CAR(walker));
  1503.     }
  1504.   NARY_PUSH_ARG(lastarg);
  1505.   gf=ARG_2(stackbase);
  1506.   return(NARY_EUCALL_1(generic_apply,gf));
  1507.   END_NARY_EUCALL();
  1508. }
  1509. EUFUN_CLOSE
  1510.  
  1511. EUFUN_2(module_mv_apply_1,op, form)
  1512. {
  1513.   LispObject module_apply_args(LispObject *, int , LispObject );
  1514.   LispObject *walker=stackbase;
  1515.   int n=0;
  1516.  
  1517.   while (is_cons(form))
  1518.     {
  1519.       *walker=CAR(form);
  1520.       form=CDR(form);
  1521.       walker++;
  1522.       n++;
  1523.     }
  1524.  
  1525.   if (form!=nil)
  1526.     CallError(stackbase,"Improper list passed to mv_apply",nil,NONCONTINUABLE);
  1527.  
  1528.   return(module_apply_args(stackbase,n,op));
  1529.   
  1530. }
  1531. EUFUN_CLOSE
  1532.  
  1533. /* More restatement */
  1534. LispObject module_apply_args(LispObject *stackbase, int callargs, LispObject fn)
  1535. {
  1536.   void listify_args(LispObject *,int ,LispObject *);
  1537.   LispObject *stacktop=stackbase+callargs;
  1538.  
  1539.   if (is_i_function(fn) || is_i_macro(fn))
  1540.     {
  1541.       int nargs=fn->I_FUNCTION.argtype;
  1542.       LispObject env=fn->I_FUNCTION.env;
  1543.       LispObject args;
  1544.       LispObject *walker=stackbase;
  1545.       int extras;
  1546.       
  1547.       extras= (nargs<0);
  1548.       
  1549.       if (nargs==0 && callargs==0)
  1550.     RETURN_EUCALL(EUCALL_3(Sf_progn,
  1551.                    fn->I_FUNCTION.home,
  1552.                    env,
  1553.                    fn->I_FUNCTION.body));
  1554.  
  1555.       if ( (callargs!=nargs)
  1556.       && (!extras || (extras && callargs < -nargs-1)))
  1557.     CallError(stackbase,"apply: i-function called with wrong number of args",fn,NONCONTINUABLE);
  1558.       
  1559.       STACK_TMP(fn);    /* we stack it twice on the off chance */
  1560.       STACK_TMP(fn);    /* it is an nary function called with n-1 args */
  1561.       for (args=fn->I_FUNCTION.bvl;
  1562.        is_cons(args);
  1563.        )
  1564.     {
  1565.       STACK_TMP(CDR(args));
  1566.       env=allocate_env(stacktop,CAR(args),*walker,env);
  1567.       walker++;
  1568.       UNSTACK_TMP(args);
  1569.     }
  1570.       if (args!=nil)
  1571.     {
  1572.       STACK_TMP(env); STACK_TMP(args);
  1573.       if (callargs!=nargs)
  1574.         listify_args(walker,callargs+nargs+1,stacktop);
  1575.  
  1576.       UNSTACK_TMP(args); UNSTACK_TMP(env);
  1577.       env=allocate_env(stacktop,args,*walker,env);
  1578.     }
  1579.       UNSTACK_TMP(fn);
  1580. #if 0 /* Stack paranioa */
  1581.       if (!is_i_function(fn) && !is_i_macro(fn))
  1582.     system_lisp_exit(0);
  1583. #endif
  1584.       RETURN_EUCALL(EUCALL_3(Sf_progn,
  1585.                  fn->I_FUNCTION.home,
  1586.                  env,
  1587.                  fn->I_FUNCTION.body));
  1588.       
  1589.     }    
  1590.   
  1591.   if (is_c_function(fn) || is_c_macro(fn) 
  1592. #ifdef BCI      
  1593.       || is_b_function(fn) || is_b_macro(fn)
  1594. #endif
  1595.       )
  1596.     {
  1597. #ifdef BCI
  1598.       int nargs=
  1599.     ((is_c_function(fn)||is_c_macro(fn))
  1600.      ? fn->C_FUNCTION.argtype
  1601.      : intval(bytefunction_nargs(fn)));
  1602. #else
  1603.       int nargs = fn->C_FUNCTION.argtype;
  1604. #endif
  1605.       if (is_c_function(fn) && fn->C_FUNCTION.env!=NULL)
  1606.     {    /* Whups --- the env needs to be inserted */
  1607.       int i;
  1608.       
  1609.       for (i=callargs; i>=0; i--)
  1610.         stackbase[i+1]=stackbase[i];
  1611.  
  1612.       stackbase[0]=(LispObject)fn->C_FUNCTION.env;
  1613.     }
  1614.       if (callargs!=nargs)
  1615.     {
  1616.       if (nargs<0 && callargs>= -nargs-1)
  1617.         {    
  1618.           int act= -nargs-1;
  1619.  
  1620.           STACK_TMP(fn); /* could be anything --- just to stop the */
  1621.           STACK_TMP(fn); /* value being blatted */
  1622.           listify_args(stackbase+act,callargs-act,stacktop);
  1623.           UNSTACK_TMP(fn);
  1624.         }
  1625.       else
  1626.         CallError(stacktop,"C function called with wrong number of args",fn,NONCONTINUABLE);
  1627.     }
  1628. #ifdef BCI
  1629.       if (is_c_function(fn) || is_c_macro(fn))
  1630.     return((fn->C_FUNCTION.func)(stackbase));
  1631.       else
  1632.     return(apply_nary_bytefunction(stackbase,
  1633.                        nargs>0 ? nargs : -nargs,
  1634.                        fn));
  1635. #else
  1636.       return((fn->C_FUNCTION.func)(stackbase));
  1637. #endif      
  1638.     }            
  1639.  
  1640.   if (is_generic(fn))
  1641.     {    
  1642.       int nargs=intval(generic_argtype(fn));
  1643.       
  1644.       if (nargs!=callargs)
  1645.     CallError(stacktop,"Generic called with wrong number of args",fn,NONCONTINUABLE);
  1646.  
  1647.       return(generic_apply(stackbase,fn));
  1648.     }
  1649.  
  1650.   if (is_continue(fn))
  1651.     {
  1652.       if (callargs==0)
  1653.     {
  1654.       call_continuation(stackbase,fn,nil);
  1655.       return nil; 
  1656.     }
  1657.  
  1658.       if (callargs==1)
  1659.     {
  1660.       call_continuation(stackbase,fn,*stackbase);
  1661.     }
  1662.       CallError(stackbase,"apply: continuation: too many args",fn,NONCONTINUABLE);
  1663.       /* nope */
  1664.       return nil;
  1665.     }
  1666.   
  1667.   /* default case */
  1668.     if (CAR(Cb_no_function_fn)==nil)
  1669.       {
  1670.     CallError(stacktop,"Apply: Invalid operator",nil,NONCONTINUABLE);
  1671.       }
  1672.   else
  1673.     {
  1674.       int i;
  1675.     
  1676.       for (i=callargs; i>=0; i--)
  1677.     stackbase[i+1]=stackbase[i];
  1678.  
  1679.       stackbase[0]=fn;
  1680.     
  1681.       return(module_apply_args(stackbase,callargs+1,CAR(Cb_no_function_fn)));
  1682.     }
  1683. }
  1684.  
  1685. /* Should be a macro */
  1686. void listify_args(LispObject *start,int n,LispObject *stacktop)
  1687. {
  1688.   int i;
  1689.   LispObject lst;
  1690.  
  1691.   if (n==0)
  1692.     {
  1693.       *start=nil;
  1694.       return;
  1695.     }
  1696.   
  1697.   lst=allocate_n_conses(stacktop,n);
  1698.   CAR(lst)= *start;
  1699.   *start = lst;
  1700.  
  1701.   start++;
  1702.   lst=CDR(lst);
  1703.   for (i=1; i<n; i++)
  1704.     {
  1705.       CAR(lst) = *start;
  1706.       lst=CDR(lst);
  1707.       start++;
  1708.     }
  1709. }
  1710. #define SYM_REF_DBG(x) /* x;fflush(stderr); */
  1711.  
  1712. LispObject symbol_ref(LispObject *stacktop,
  1713.              LispObject mod,LispObject env,LispObject sym)
  1714. {
  1715.   LispObject walker;
  1716.   LispObject spec;
  1717.  
  1718. SYM_REF_DBG(fprintf(stderr,"symol_ref with sym '%s'\n",stringof(sym->symbol.pname)));
  1719.  
  1720.   /* parameter environment */
  1721.  
  1722.   walker = env;
  1723.  
  1724. SYM_REF_DBG(fprintf(stderr,"symol_ref env search\n"));
  1725.  
  1726.   while (walker != NULL) {
  1727.     if (walker->ENV.variable == sym) 
  1728.       return(walker->ENV.value);
  1729.     else
  1730.       walker = walker->ENV.next;
  1731.   }
  1732.  
  1733.   if (SYM_CACHE_MODULE(sym) == mod)
  1734.     return(SYM_CACHE_VALUE(sym));
  1735.  
  1736.   /* self evaluating symbols */
  1737.  
  1738.   if (sym == sym_nil) return(nil);
  1739.   if (sym == lisptrue) return(lisptrue);
  1740.   
  1741.   /* Check caches */
  1742.   /* language constructs and key words */
  1743.  
  1744.   spec=EUCALL_2(Fn_table_ref,special_table,sym);
  1745.  
  1746.   if (spec != nil) 
  1747.     {
  1748.       SYM_CACHE_SET(sym,mod,spec);
  1749.       return spec;    
  1750.     }
  1751.   
  1752.   /* module reference */
  1753.  
  1754.   return(EUCALL_2(Fn_module_value,mod,sym));
  1755. }
  1756.  
  1757.  
  1758. LispObject module_set_new(LispObject *stacktop,LispObject mod,LispObject sym,LispObject val)
  1759. {
  1760.   return(EUCALL_4(module_set_new_aux,mod,sym,val,lisptrue));
  1761. }
  1762.  
  1763. LispObject module_set_new_constant(LispObject *stacktop,LispObject mod,
  1764.                    LispObject sym,LispObject val)
  1765. {
  1766.   return(EUCALL_4(module_set_new_aux,mod,sym,val,nil));
  1767. }
  1768.  
  1769.  
  1770. EUFUN_2(Fn_module_value, mod, sym)
  1771. {
  1772.   LispObject bind;
  1773.   
  1774.   bind=GET_BINDING(mod,sym);
  1775.  
  1776.   if (bind==nil)
  1777.     {
  1778.       LispObject xx;
  1779.       xx=EUCALL_2(Fn_cons,mod->MODULE.name,sym);
  1780.       CallError(stacktop,"module value: No such binding",xx,NONCONTINUABLE);
  1781.     }
  1782.   if (is_bind(bind))
  1783.     { /* Good value */
  1784.       LispObject val;
  1785.  
  1786.       if (is_i_module(BINDING_HOME(bind)))
  1787.     {
  1788.       val = BINDING_VALUE(bind);
  1789.       SYM_CACHE_SET(sym,mod,val);
  1790.       return val;
  1791.     }
  1792.       if (is_c_module(BINDING_HOME(bind)))
  1793.     {
  1794.       val=vref((BINDING_HOME(bind)->C_MODULE.values),intval(BINDING_VALUE(bind)));
  1795.       SYM_CACHE_SET(sym,mod,val);
  1796.       return val;
  1797.     }
  1798.       else 
  1799.     CallError(stacktop,"Unexpected module type",bind,NONCONTINUABLE);    
  1800.     }
  1801.  
  1802.   CallError(stacktop,"Unexpected value of binding",bind,NONCONTINUABLE);
  1803.   return nil;
  1804. }
  1805. EUFUN_CLOSE
  1806.  
  1807. EUFUN_3(module_set,mod, sym, val)
  1808. {
  1809.   LispObject bind;
  1810.  
  1811.   
  1812.   if (is_c_module(mod))
  1813.     CallError(stacktop,"module set: can't set in compiled module",sym,NONCONTINUABLE);
  1814.  
  1815.   if(reserved_symbol_p(sym))
  1816.     CallError(stacktop,"module set: can't set reserved symbol",sym,NONCONTINUABLE);
  1817.  
  1818.   bind=GET_BINDING(mod,sym);
  1819.   mod=ARG_0(stackbase);
  1820.   sym=ARG_1(stackbase);
  1821.   val=ARG_2(stackbase);
  1822.   if (bind==nil)
  1823.     {    /* Be kind and add it anyhow */
  1824.       SYM_CACHE_SET(sym,mod,val);
  1825.  
  1826.       ADD_BINDING(ARG_0(stackbase)/* mod*/, ARG_1(stackbase)/*sym*/,
  1827.           ARG_2(stackbase)/*val*/,lisptrue);
  1828.       return ARG_2(stackbase);
  1829.     }
  1830.   
  1831.   if (BINDING_MUTABLE(bind))
  1832.     {
  1833.       SYM_CACHE_SET(sym,mod,val);
  1834.       BINDING_VALUE(bind)=val;
  1835.       return val;
  1836.     }
  1837.   else
  1838.     {
  1839.       SYM_CACHE_SET(sym,mod,val);
  1840.       
  1841.       if (is_c_module(BINDING_HOME(bind)))
  1842.     CallError(stacktop,"Binding not assignable.", bind, NONCONTINUABLE);
  1843.  
  1844.       print_string(stacktop,StdErr(),"*** Setting immutable binding:");
  1845.       print_string(stacktop,StdErr(),stringof(sym->SYMBOL.pname));
  1846.       BINDING_VALUE(bind)=val;
  1847.       return val;
  1848.     }
  1849.   
  1850.   CallError(stacktop,"module set: How the hell did I get here",sym,NONCONTINUABLE);
  1851.   return nil;
  1852. }
  1853. EUFUN_CLOSE
  1854.  
  1855. static EUFUN_4(module_set_new_aux,mod,sym,val,mutability)
  1856. {
  1857.   LispObject bind;
  1858.  
  1859.   if (!is_i_module(mod))
  1860.     CallError(stacktop,"Module set new: tried to set in compiled module",sym,NONCONTINUABLE);
  1861.  
  1862.   if(reserved_symbol_p(sym))
  1863.     CallError(stacktop,"module set: can't set reserved symbol",sym,NONCONTINUABLE);
  1864.  
  1865.   bind=GET_BINDING(mod,sym);
  1866.   
  1867.   if (bind==nil)
  1868.     { /* Its a newie */
  1869.       SYM_CACHE_INIT(sym);
  1870.       SYM_CACHE_SET(sym,mod,val);
  1871.       ADD_BINDING(ARG_0(stackbase),ARG_1(stackbase),ARG_2(stackbase),ARG_3(stackbase));
  1872.       return ARG_1(stackbase);
  1873.     }
  1874.   else
  1875.     {
  1876.       if (BINDING_HOME(bind)==mod)
  1877.     {
  1878.       SYM_CACHE_SET(sym,mod,val);
  1879.       BINDING_VALUE(bind)=val;
  1880.       SET_BINDING_MUTABLE(bind,mutability);
  1881.       return sym;
  1882.     }
  1883.       else
  1884.     CallError(stacktop,"Module set new: tried to set over imported binding",sym,NONCONTINUABLE);
  1885.     }
  1886.   /* NOT ever */
  1887.   return nil; 
  1888. }
  1889. EUFUN_CLOSE
  1890.  
  1891. EUFUN_4(register_module_import, mod, name, inmod, inname)
  1892. {
  1893.   LispObject bind, localbind;
  1894.   LispObject xx;
  1895.   if (is_c_module(mod))
  1896.     CallError(stacktop, "register import: can't import into compiled module",
  1897.           mod,NONCONTINUABLE);
  1898.  
  1899.   /* Into canonical form */
  1900.   bind=GET_BINDING(inmod,inname);
  1901.   if (bind==nil)
  1902.     {
  1903.       xx=EUCALL_2(Fn_cons,inmod->C_MODULE.name,inname);
  1904.       CallError(stacktop,"non-existent binding exported", xx,NONCONTINUABLE);
  1905.     }
  1906.  
  1907.   /* ok, but is it exported anyhow ? */
  1908.   if (!BINDING_EXPORTED(bind))
  1909.     {    
  1910.       EUCALLSET_2(xx, Fn_memq, inname, module_exports(inmod));
  1911.       if (xx == nil)
  1912.     CallError(stacktop, "register import: name not exported",inname,
  1913.           NONCONTINUABLE);
  1914.       else
  1915.     SET_BINDING_EXPORT(bind);
  1916.     }
  1917.   
  1918.   /* See if we have something of the same name */
  1919.   localbind=GET_BINDING(mod,name);
  1920.  
  1921.   if (localbind==nil)
  1922.     { /* add it */
  1923.       STACK_TMP(bind);
  1924.       SYM_CACHE_INIT(name);
  1925.       UNSTACK_TMP(bind);
  1926.       IMPORT_BINDING(ARG_0(stackbase),ARG_1(stackbase),bind);
  1927.       return nil;
  1928.     }
  1929.   else 
  1930.     {
  1931.       if (bind==localbind) /* done this before */
  1932.     return nil;
  1933.       else 
  1934.     {
  1935.       xx=EUCALL_2(Fn_cons, inmod->C_MODULE.name,name);
  1936.       CallError(stacktop,"register import: binding exists locally",xx,NONCONTINUABLE);
  1937.     }
  1938.     }
  1939.  
  1940.   CallError(stacktop,"Register import: Yeouch. not here",nil,NONCONTINUABLE);
  1941.  
  1942.   return nil;
  1943. }
  1944. EUFUN_CLOSE
  1945.  
  1946. int module_binding_exists_p(LispObject *stacktop,LispObject mod,LispObject name)
  1947. {
  1948.   LispObject bind;
  1949.   
  1950.   bind=GET_BINDING(mod,name);
  1951.   
  1952.   return (bind!=nil);
  1953. }    
  1954.  
  1955.  
  1956. /* *************************************************************** */
  1957. /* Initialisation of this section                                  */
  1958. /* *************************************************************** */
  1959.  
  1960. void initialise_modules(LispObject *stacktop)
  1961. {
  1962.   extern MODULE *current_open_module;
  1963.  
  1964.   sym_include_forms = get_symbol(stacktop,"include-forms");
  1965.   add_root(&sym_include_forms);
  1966.   SYSTEM_INITIALISE_GLOBAL(LispObject,current_interactive_module,NULL);
  1967.   ADD_SYSTEM_GLOBAL_ROOT(current_interactive_module);
  1968.   global_module_table = (LispObject) EUCALL_1(make_table,NULL);
  1969.   add_root(&global_module_table);
  1970.   add_root((LispObject*)¤t_open_module);
  1971.   backtrace_handle = get_symbol(stacktop,"****backtrace-handle****");
  1972.   add_root(&backtrace_handle);
  1973.   sym_only   = get_symbol(stacktop,"only");
  1974.   add_root(&sym_only);
  1975.   sym_except = get_symbol(stacktop,"except");
  1976.   add_root(&sym_except);
  1977.   Cb_no_function_fn=EUCALL_2(Fn_cons,nil,nil);
  1978.   add_root(&Cb_no_function_fn);
  1979. }
  1980.  
  1981.